(FILECREATED " 1-OCT-73 22:35:51" MATCH)


(LISPXPRINT (QUOTE MATCHVARS) T)
(RPAQQ MATCHVARS ((* TOP LEVEL) (FNS MAKEMATCH 'MATCHWM 'MATCHTOP
'MATCHEXP 'MATCHELT 'MATCHSUBPAT) (* Funargs for 'MATCHWM) (FNS 
MAKE'SETQ MAKEPOSTPONEDSETQ MAKE'REPLACE MAKEPOSTPONEDREPLACE 
MAKE'APPLY* MAKE'RETURN MAKE*GLITCH) (* PREDICATES ON PATTERNS) (FNS
SKIP$I SKIP$ANY PATLEN $? ELT? ARB? NULLPAT? CANMATCHNIL CANMATCHNILLIST
REPLACEIN REPLACED) (* LISP FUNCTION MANIPULATION) (FNS EASYTORECOMPUTE
FULLEXPANSION GENSYML MAKESUBST0 MAKESUBSTLIST MAKESUBSTLIST1 FORMEXPAND
POSTPONEDREPLACE POSTPONEDSETQ POSTPONE SUBSTVAR BOUNDVAR BINDVAR
SELFQUOTEABLE FINDIN0 FINDIN1 DOWATCH UNCROP PATNARGS) (* LISP FUNCTION
CONSTRUCTION) (FNS 'NLEFT 'NOT 'NULL 'NOT1 'NOTLESSPLENGTH 'NTH 'OR
'PLUS 'REPLACE 'SETQ 'AND 'AND2 'CAR 'CDR 'EQ 'EQLENGTH 'EQUAL 'LAST
'RETURN 'F/L 'APPLY* 'HEADPLOOP 'LDIFF 'PROG 'FOR 'PROGN 'LISTP) (*
PATTERN PARSER) (FNS PATPARSE PATPARSE1 PATPARSEAT PATPARSEXPR BI12
MAKEDEFAULT MAKE!PAT MAKESUBPAT) (* FUNCTIONS, CALLS TO WHICH ARE
GENERATED) (FNS EQLENGTH RPLNODE2 /RPLNODE2) (* MISC) (FNS PATERR
PATHELP PATWARN LOOKLIST LOOK CLISPLOOKUP VARCHECK TRUE) (VARS 
VARDEFAULT MAXCDDDDRS POSTPONEFLG PATCHECKLENGTH POSTPONEFLG 
PATCAREVALUE CRLIST PATCHARS PATNONNILFUNCTIONS PATVARSMIGHTBENIL)
(PROP MACRO EVERY) (ADDVARS (PRETTYMACROS (* X (E (TERPRI) (PRINT
(QUOTE (* . X))) (TERPRI))))) (P (SETQ PATCHARRAY (MAKEBITTABLE (MAPCAR
PATCHARS (QUOTE CAR))))) (BLOCKS (MATCHBLOCK MAKEMATCH 'MATCHWM 
'MATCHTOP 'MATCHEXP 'MATCHELT 'MATCHSUBPAT MAKE'SETQ MAKEPOSTPONEDSETQ
MAKE'REPLACE MAKEPOSTPONEDREPLACE MAKE'APPLY* MAKE'RETURN MAKE*GLITCH
SKIP$I SKIP$ANY PATLEN $? ELT? ARB? NULLPAT? CANMATCHNIL CANMATCHNILLIST
REPLACEIN REPLACED EASYTORECOMPUTE FULLEXPANSION GENSYML MAKESUBST0
MAKESUBSTLIST MAKESUBSTLIST1 FORMEXPAND POSTPONEDREPLACE POSTPONEDSETQ
POSTPONE SUBSTVAR BOUNDVAR BINDVAR SELFQUOTEABLE FINDIN0 FINDIN1 DOWATCH
UNCROP 'NLEFT 'NOT 'NULL 'NOT1 'NOTLESSPLENGTH 'NTH 'OR 'PLUS 'REPLACE
'SETQ 'AND 'AND2 'CAR 'CDR 'EQ 'EQLENGTH 'EQUAL 'LAST 'RETURN 'APPLY*
'HEADPLOOP 'LDIFF 'PROG 'FOR 'F/L 'PROGN 'LISTP PATPARSE PATPARSE1
PATPARSEAT PATPARSEXPR BI12 MAKEDEFAULT MAKE!PAT MAKESUBPAT PATERR
PATHELP PATWARN LOOKLIST LOOK CLISPLOOKUP VARCHECK PATNARGS TRUE 
EQLENGTH (ENTRIES MAKEMATCH) (GLOBALVARS PATCHARRAY PATCHARS POSTPONEFLG
VARDEFAULT CRLIST PATCHECKLENGTH MAXCDDDDRS PATNONNILFUNCTIONS 
PATVARSMIGHTBENIL) (LOCALFREEVARS WATCHPOSTPONELST SUBLIST TOPPAT
INASOME CHECKINGLENGTH WMLST LASTEFFECTCANBENIL POSTPONEDEFFECTS 
MUSTRETURN BINDINGS GENSYMVARLIST SKIPEDLEN ZLENFLG SUBPRS STARREPLACED)
(SPECVARS STARREPLACED) (BLKAPPLYFNS TRUE MAKE'RETURN MAKE*GLITCH
MAKE'SETQ MAKEPOSTPONEDSETQ MAKE'REPLACE MAKEPOSTPONEDREPLACE 
MAKE'APPLY* 'MATCHWM 'MATCHSUBPAT)) (NIL EQLENGTH RPLNODE2 /RPLNODE2
(LINKFNS . T)))))

(* TOP LEVEL)

(DEFINEQ

(MAKEMATCH
(LAMBDA (VAR TOPPAT STARREPLACED) ('MATCHTOP VAR (PATPARSE TOPPAT))))

('MATCHWM
(LAMBDA (VAR PAT FN) (* Creates an expression which will return non-NIL
if and only if the value of the VAR expression will match the parsed
pattern PAT, and the expression generated by applying (CAR FN) to
(the expression giving What-Matched the first pattern element of PAT)
and (CDR FN) - is non-nil as well. FN can hide side effects as well)
(PROG (TEM1 TEM2 TAIL (SKIPEDLEN 0) ZLENFLG IN@FLG) RETRY (COND ((NULL
PAT) (RETURN (OR (NOT CHECKINGLENGTH) ('NULL VAR)))) ((NLISTP (CAR
PAT)) (COND ((NOT (FMEMB (CAR PAT) (QUOTE ($ --)))) (GO ELT)) (T (GO
TAIL)))) ((FMEMB (CAAR PAT) (QUOTE (= == ' SUBPAT))) (GO ELT)) ((EQ
(CAAR PAT) (QUOTE !)) (GO BANG)) ((EQ (CAAR PAT) (QUOTE $PACKED$))
(GO PACKED))) (SETQ FN (SELECTQ (CAAR PAT) (← (CONS (FUNCTION MAKE'SETQ)
(CONS (CDAR PAT) FN))) (<- (CONS (FUNCTION MAKEPOSTPONEDSETQ) (CONS
(CDAR PAT) FN))) (→ (CONS (FUNCTION MAKE'REPLACE) (CONS (CDAR PAT)
FN))) (-> (CONS (FUNCTION MAKEPOSTPONEDREPLACE) (CONS (CDAR PAT) FN)))
(@ (CONS (FUNCTION MAKE'APPLY*) (CONS (CDAR PAT) FN))) (* (CONS (
FUNCTION MAKE'RETURN) FN)) (*GLITCH (CONS (FUNCTION MAKE*GLITCH) (CONS
(CDAR PAT) FN))) (PATHELP "INVALID PATTERN" (CAR PAT)))) (FRPLACA
PAT (SELECTQ (CAAR PAT) (* (CDAR PAT)) (CDDAR PAT))) (GO RETRY) BANG
(RETURN (COND ((NULL (CDR PAT)) ('AND (BLKAPPLY* (CAR FN) VAR (CDR
FN)) (COND ((EQ (CADAR PAT) (QUOTE SUBPAT)) (* This isn't really a
subpat and so don't rebind CHECKINGLENGTH etc as in 'MATCHSUBPAT)
('MATCHWM VAR (CDDAR PAT) (QUOTE (TRUE)))) (T ('MATCHELT VAR (CDAR
PAT)))))) ((NLISTP (CAR PAT)) (PATERR "INVALID !")) (T (SELECTQ (CADAR
PAT) (= (* !=) ('HEADPLOOP VAR (CDDAR PAT) (SETQ TEM1 (BOUNDVAR))
(CANMATCHNILLIST (CDR PAT)) ('AND (BLKAPPLY* (CAR FN) ('LDIFF VAR
TEM1) (CDR FN)) ('MATCHWM TEM1 (CDR PAT) (QUOTE (TRUE)))))) (== (PATERR
"!== in middle of pattern")) (' (AND (OR (NLISTP (CDDAR PAT)) (CDR
(LAST (CDDAR PAT)))) (PATERR "!'atom in middle of pattern")) ('MATCHWM
VAR (CONS (CONS (QUOTE !) (CONS (QUOTE SUBPAT) (MAPCAR (CDDAR PAT)
(FUNCTION (LAMBDA (X) (CONS (QUOTE ') X)))))) (CDR PAT)) FN)) (SUBPAT
(* USE THE *GLITCH KLUDGE TO GET THE WHATMATCHED OF THE REST OF THE
THING) (COND ((EQ (CAR FN) (QUOTE TRUE)) ('MATCHWM VAR (APPEND (CDDAR
PAT) (CDR PAT)) (QUOTE (TRUE)))) (T (SETQ WMLST (CONS NIL WMLST))
(SETQ TEM1 ('AND ('MATCHWM VAR (APPEND (CDDAR PAT) (LIST (CONS (QUOTE
*GLITCH) (CONS WMLST (CONS (QUOTE !) (CONS (QUOTE SUBPAT) (CDR PAT)))))))
(QUOTE (TRUE))) (BLKAPPLY* (CAR FN) ('LDIFF VAR (CAR WMLST)) (CDR
FN)))) (SETQ WMLST (CDR WMLST)) TEM1))) (PATHELP "INVALID PATTERN HERE:"
(CADAR PAT)))))) PACKED (RETURN (COND ((NULL (CDR PAT)) ('AND (OR
(NOT CHECKINGLENGTH) ('EQLENGTH VAR (CDAR PAT))) (BLKAPPLY* (CAR FN)
VAR (CDR FN)))) ((AND (EQ (CAR FN) (QUOTE TRUE)) (COND ((NULLPAT?
(SETQ TAIL (SKIP$I (CDR PAT)))) (OR (NOT CHECKINGLENGTH) (
'NOTLESSPLENGTH VAR ('PLUS (CDAR PAT) SKIPEDLEN)))) ((NULL TAIL) (
'EQLENGTH VAR ('PLUS (CDAR PAT) SKIPEDLEN)))))) (T (SETQ TEM1 (SUBSTVAR
('NTH VAR (CDAR PAT)))) ('AND (OR (NOT (CANMATCHNILLIST (CDR PAT)))
TEM1) (BLKAPPLY* (CAR FN) ('LDIFF VAR ('CDR TEM1)) (CDR FN)) ('MATCHWM
('CDR TEM1) (CDR PAT) (QUOTE (TRUE))))))) ELT (RETURN ('AND (OR (NOT
CHECKINGLENGTH) (COND ((CANMATCHNIL (CAR PAT)) (COND ((NULL (CDR PAT))
('EQLENGTH VAR 1)) ((NULLPAT? (CDR PAT)) VAR) (T (OR (NOT (
CANMATCHNILLIST (CDR PAT))) VAR)))) (T (COND ((NULL (CDR PAT)) ('NULL
('CDR VAR))) (T T))))) ('MATCHELT ('CAR VAR) (CAR PAT)) (BLKAPPLY*
(CAR FN) ('CAR VAR) (CDR FN)) (OR (NULL (CDR PAT)) ('MATCHWM ('CDR
VAR) (CDR PAT) (QUOTE (TRUE)))))) TAIL (COND ((NULL (CDR PAT)) (*
Pattern ends in --) (RETURN (BLKAPPLY* (CAR FN) VAR (CDR FN)))) ((ARB?
(CADR PAT)) (COND ((MEMB (QUOTE MAKE'APPLY*) FN) (* Got ($@FOO $ ...)
this is ($ ! ($ ...) @ (lambda (z) (FOO (LDIFF var z))))) (SETQ IN@FLG
T) (GO MAKESOME)) (INASOME (GO INASOME)) ((OR (SKIP$ANY (CDDR PAT))
(NOT (ZEROP SKIPEDLEN))) (* ($ ARB -- }FIXED) I.e. two arb's in a
row, followed by something) (PATWARN 
"Two arbitrary segments in a row - ignoring first") ('AND (BLKAPPLY*
(CAR FN) NIL (CDR FN)) ('MATCHWM VAR (CDR PAT) (QUOTE (TRUE))))) (T
(* Have two $'s in a row -- kludge to mean last, if there isn't anything
after the second one) (GO LASTKLUDGE)))) (INASOME (GO INASOME)) ((AND
(EQ (CAR FN) (QUOTE TRUE)) (PROGN (SETQ TAIL (SKIP$I (CDR PAT))) (NOT
(ZEROP SKIPEDLEN)))) (* Special check here, since might have (...
-- $4) or not need any 'NLEFT's) (GO STARTWITH$N)) ((NULL (SETQ TAIL
(SKIP$ANY (CDR PAT)))) (GO ENDINFIXED)) ((AND (EQ (CAR FN) (QUOTE
TRUE)) (EQ TAIL (CDDR PAT)) (EQ SKIPEDLEN 1) (NULLPAT? TAIL) (EQ (CAADR
PAT) (QUOTE SUBPAT)) (EVERY (CDDR (CADR PAT)) (FUNCTION ARB?)) (COND
((NLISTP (CADR (CADR PAT))) (NOT (FMEMB (CADR (CADR PAT)) (QUOTE (&
$ --))))) (T (FMEMB (CAR (CADR (CADR PAT))) (QUOTE (= == '))))) (FMEMB
(CAR (SETQ TEM1 ('MATCHELT (QUOTE DUMMY) (CADR (CADR PAT))))) (QUOTE
(EQ EQUAL)))) (* PAT: (-- (SUBPAT EQTYPE? ARB?) --)) (RETURN ('MATCHEXP
(LIST (SELECTQ (CAR TEM1) (EQ (LOOK (QUOTE ASSOC) VAR)) (QUOTE SASSOC))
(CADDR TEM1) VAR) (CONS (QUOTE &) (CDDR (CADR PAT))) NIL (QUOTE 
'MATCHSUBPAT))))) MAKESOME (RETURN (PROG ({OLD⎇ {FINALLY⎇EXPR 
{UNTIL⎇EXPR {ON⎇VAR (TEMVAR (GENSYML)) (INASOME (QUOTE INASOME)))
(SETQ WATCHPOSTPONELST (CONS TEMVAR WATCHPOSTPONELST)) (* 
WATCHPOSTPONELST is reset so that postponed uses of it can be detected;
needed to set {OLD⎇) (COND ((AND (REPLACED (CDR PAT)) (EQ (CAR (SETQ
TEM1 (FULLEXPANSION VAR))) (QUOTE CDR))) (SETQ {ON⎇VAR (CADR TEM1))
(SETQ TEM2 ('CDR TEMVAR))) (T (SETQ {ON⎇VAR VAR) (SETQ TEM2 TEMVAR)))
(SETQ {UNTIL⎇EXPR ('MATCHWM TEM2 (CDR PAT) (QUOTE (TRUE)))) (COND
(IN@FLG (SETQ {UNTIL⎇EXPR ('AND {UNTIL⎇EXPR (BLKAPPLY* (CAR FN) ('LDIFF
VAR TEM2) (CDR FN)))) (SETQ {FINALLY⎇EXPR (OR (EQ INASOME (QUOTE INASOME))
INASOME))) (T (SETQ {FINALLY⎇EXPR ('AND (BLKAPPLY* (CAR FN) ('LDIFF
VAR TEM2) (CDR FN)) (OR (EQ INASOME (QUOTE INASOME)) INASOME)))))
(SETQ {OLD⎇ (EQ (CAR WATCHPOSTPONELST) (QUOTE FOUND))) (SETQ 
WATCHPOSTPONELST (CDR WATCHPOSTPONELST)) ('FOR {OLD⎇ TEMVAR {ON⎇VAR
{UNTIL⎇EXPR {FINALLY⎇EXPR (CANMATCHNILLIST (CDR PAT))))) ENDINFIXED
(RETURN (PROG (CHECKINGLENGTH) (* If pat ends in (... -- & & &) then
just match (NLEFT var 3) against & & &; CECHINGLENGTH will keep a
(NULL (CDDDR x)) check away) (COND ((AND (REPLACED (CDR PAT)) (EQ
(CAR (SETQ TEM2 (FULLEXPANSION VAR))) (QUOTE CDR))) (SETQ TEM1 (SUBSTVAR
('NLEFT (CADR TEM2) ('PLUS SKIPEDLEN 1) NIL ZLENFLG))) ('AND (OR (NOT
(EVERY (CDR PAT) (FUNCTION CANMATCHNIL))) (COND ((ZEROP SKIPEDLEN)
TEM1) (T ('CDR TEM1)))) ('MATCHWM ('CDR TEM1) (CDR PAT) (QUOTE (TRUE)))
(BLKAPPLY* (CAR FN) ('LDIFF VAR ('CDR TEM1)) (CDR FN)))) ((ZEROP 
SKIPEDLEN) (SETQ TEM1 (SUBSTVAR (LIST (QUOTE LAST) VAR))) ('AND (COND
((CANMATCHNILLIST (CDR PAT)) TEM1)) ('MATCHWM ('CDR TEM1) (CDR PAT)
(QUOTE (TRUE))) (BLKAPPLY* (CAR FN) ('LDIFF VAR ('CDR TEM1)) (CDR
FN)))) (T (SETQ TEM1 (SUBSTVAR ('NLEFT VAR SKIPEDLEN NIL ZLENFLG)))
('AND (OR (NOT (EVERY (CDR PAT) (FUNCTION CANMATCHNIL))) TEM1) ('MATCHWM
TEM1 (CDR PAT) (QUOTE (TRUE))) (BLKAPPLY* (CAR FN) ('LDIFF VAR TEM1)
(CDR FN))))))) STARTWITH$N (* Starts with -- $N's --) (RETURN (COND
((OR (NULL TAIL) (NULLPAT? TAIL)) (OR (NOT CHECKINGLENGTH) (
'NOTLESSPLENGTH VAR SKIPEDLEN))) ((NUMBERP SKIPEDLEN) ('MATCHWM ('NTH
VAR (ADD1 SKIPEDLEN)) (CONS (CAR PAT) TAIL) (QUOTE (TRUE)))) (T (SETQ
TEM1 (SUBSTVAR ('NTH VAR ('PLUS SKIPEDLEN 1)))) ('MATCHWM ('CDR TEM1)
(CONS (CAR PAT) TAIL) (QUOTE (TRUE)))))) LASTKLUDGE (RETURN (COND
((REPLACED (CDR PAT)) (SETQ TEM1 (SUBSTVAR ('NLEFT VAR 2))) ('AND
(OR (NOT (CANMATCHNILLIST (CDR PAT))) TEM1) ('MATCHWM ('CDR TEM1)
(CDR PAT) (QUOTE (TRUE))) (BLKAPPLY* (CAR FN) ('LDIFF VAR ('CDR TEM1))
(CDR FN)))) (T (* Must mean the second is LAST) (SETQ TEM1 (SUBSTVAR
('LAST VAR))) ('AND ('MATCHWM TEM1 (CDR PAT) (QUOTE (TRUE))) (BLKAPPLY*
(CAR FN) ('LDIFF VAR TEM1) (CDR FN)))))) INASOME (* Reset INASOME
to the match of this pattern, and then return T; thus the INASOME
will get the correct thing to match, and yet *GLITCHES will work 
properly as well (maybe)) (COND ((NEQ INASOME (QUOTE INASOME)) (PATHELP
" SOME INASOME"))) (SETQ INASOME (PROG (INASOME) ('MATCHWM VAR PAT
FN))) (RETURN T))))

('MATCHTOP
(LAMBDA (EXPRESSION PAT) (* Generate expresion which will match PAT
against EXPRESSION) (PROG ((GENSYMVARLIST (QUOTE (GENSYMVARS: $$1
$$2 $$3 $$4 $$5 $$6 $$7 $$8 $$9 $$10 $$11 $$12 $$13 $$14 $$15 $$16
$$17))) (CHECKINGLENGTH PATCHECKLENGTH) POSTPONEDEFFECTS 
LASTEFFECTCANBENIL BINDINGS MUSTRETURN WMLST ZLENFLG SUBLIST INASOME
WATCHPOSTPONELST) (* POSTPONEDEFFECTS is the side effects postponed
- BINDINGS will be list of prog bindings that need to be done - 
MUSTRETURN will be the * expression, if any) (SETQ EXPRESSION ('MATCHEXP
EXPRESSION PAT (QUOTE (TRUE)) (QUOTE 'MATCHWM))) (COND (MUSTRETURN
(SETQ POSTPONEDEFFECTS (NCONC1 POSTPONEDEFFECTS MUSTRETURN))) ((AND
LASTEFFECTCANBENIL PATCAREVALUE) (SETQ POSTPONEDEFFECTS (NCONC1 
POSTPONEDEFFECTS T)))) (COND (POSTPONEDEFFECTS (SETQ EXPRESSION ('AND
EXPRESSION ('PROGN POSTPONEDEFFECTS))))) (AND SUBLIST (SETQ EXPRESSION
(MAKESUBSTLIST (DREVERSE SUBLIST) EXPRESSION))) (RETURN (COND (BINDINGS
('PROG BINDINGS (LIST EXPRESSION))) (T EXPRESSION))))))

('MATCHEXP
(LAMBDA (VAR PAT 3RDARG FN) (COND ((EASYTORECOMPUTE VAR) (BLKAPPLY*
FN VAR PAT 3RDARG)) (T (PROG (TEM2) (COND ((AND (REPLACED PAT) (FMEMB
(CAR (SETQ TEM2 (FULLEXPANSION VAR))) (QUOTE (CAR CDR)))) (BLKAPPLY*
FN (LIST (CAR TEM2) (SUBSTVAR (CADR TEM2))) 3RDARG)) (T (BLKAPPLY*
FN (SUBSTVAR VAR) PAT 3RDARG))))))))

('MATCHELT
(LAMBDA (VAR PATELT) (* This function matches VAR against PATELT when
PATELT is a pattern element) (COND ((NLISTP PATELT) (SELECTQ PATELT
(($ -- &) T) ('EQUAL VAR PATELT))) (T (SELECTQ (CAR PATELT) (== ('EQ
VAR (CDR PATELT))) (' ('EQUAL VAR (KWOTE (CDR PATELT)))) (= ('EQUAL
VAR (CDR PATELT))) (SUBPAT ('MATCHSUBPAT VAR (CDR PATELT))) ($PACKED$
(OR (NOT CHECKINGLENGTH) ('EQLENGTH VAR (CDR PATELT)))) (PATHELP 
"MATCHELT invalid pattern"))))))

('MATCHSUBPAT
(LAMBDA (VAR PATELT) (PROG ((CHECKINGLENGTH PATCHECKLENGTH) INASOME)
('MATCHWM VAR PATELT (QUOTE (TRUE))))))
)

(* Funargs for 'MATCHWM)

(DEFINEQ

(MAKE'SETQ
(LAMBDA (X ARGS) (* CAR ARGS is old PAT, CDR ARGS is old FN) ('AND
('SETQ (CAR (CAR ARGS)) X (CANMATCHNIL (CDR (CAR ARGS)))) (BLKAPPLY*
(CAR (CDR ARGS)) X (CDDR ARGS)))))

(MAKEPOSTPONEDSETQ
(LAMBDA (X ARGS) (* CAR ARGS is old PAT, CDR ARGS is old FN) ('AND
(POSTPONEDSETQ (CAR (CAR ARGS)) X (CANMATCHNIL (CDR (CAR ARGS))))
(BLKAPPLY* (CAR (CDR ARGS)) X (CDDR ARGS)))))

(MAKE'REPLACE
(LAMBDA (X ARGS) (* CAR ARGS is old PAT, CDR ARGS is old FN) ('AND
('REPLACE X (CAR (CAR ARGS))) (BLKAPPLY* (CAR (CDR ARGS)) X (CDDR
ARGS)))))

(MAKEPOSTPONEDREPLACE
(LAMBDA (X ARGS) (* CAR ARGS is old PAT, CDR ARGS is old FN) ('AND
(POSTPONEDREPLACE X (CAR (CAR ARGS))) (BLKAPPLY* (CAR (CDR ARGS))
X (CDDR ARGS)))))

(MAKE'APPLY*
(LAMBDA (X ARGS) (* CAR ARGS is old PAT, CDR ARGS is old FN) ('AND
('APPLY* (CAR (CAR ARGS)) X) (BLKAPPLY* (CAR (CDR ARGS)) X (CDDR ARGS))))
)

(MAKE'RETURN
(LAMBDA (X ARGS) (* ARGS is old FN) (DOWATCH X) ('AND ('RETURN X)
(BLKAPPLY* (CAR ARGS) X (CDR ARGS)))))

(MAKE*GLITCH
(LAMBDA (X ARGS) (* CAR ARGS is old PAT, CDR ARGS is old (CDR ARGS))
(FRPLACA (CAR (CAR ARGS)) X) (DOWATCH X) (BLKAPPLY* (CAR (CDR ARGS))
X (CDDR ARGS))))
)

(* PREDICATES ON PATTERNS)

(DEFINEQ

(SKIP$I
(LAMBDA (PAT) (* Returns to the first TAIL of PAT which doesn't begin
with a $i or a $$foo - Sets the variable "LEN" to the total length
of things skipped over) (SOME PAT (FUNCTION (LAMBDA (ELT) (COND ((EQ
ELT (QUOTE &)) (SETQ SKIPEDLEN ('PLUS 1 SKIPEDLEN)) NIL) ((EQ (CAR
ELT) (QUOTE $PACKED$)) (SETQ SKIPEDLEN ('PLUS SKIPEDLEN (CDR ELT)))
NIL) (T)))))))

(SKIP$ANY
(LAMBDA (PAT) (* Scans PAT until a pattern element which matches an
arbitrary length segment is hit) (* The free variables SETS and MATCH
are set to T if a set or MATCH (respectively) are found in any of
the pattern elements passed over) (SOME PAT (FUNCTION (LAMBDA (ELT)
(PROG (TEM) (COND ((SETQ TEM (PATLEN ELT)) (COND ((ZEROP TEM) (SETQ
ZLENFLG T)) (T (SETQ SKIPEDLEN ('PLUS SKIPEDLEN TEM)))) NIL) (T T)))))))
)

(PATLEN
(LAMBDA (PATELT !ED) (PROG NIL LP (RETURN (COND ((NLISTP PATELT) (
SELECTQ PATELT (($ --) NIL) (& (AND (NOT !ED) 1)) (COND (!ED 0) (T
1)))) (T (SELECTQ (CAR PATELT) (* (SETQ PATELT (CDR PATELT)) (GO LP))
(SUBPAT (COND (!ED (for PE1 in (CDR PATELT) bind PLEN←0 finally (RETURN
PLEN) do (SETQ PLEN ('PLUS PLEN (OR (PATLEN PE1) (RETURN NIL))))))
(T 1))) ($PACKED$ (CDR PATELT)) ((← -> <- → @ *GLITCH) (SETQ PATELT
(CDDR PATELT)) (GO LP)) (! (SETQ PATELT (CDR PATELT)) (SETQ !ED T)
(GO LP)) (' (COND (!ED (LENGTH (CDR PATELT))) (T 1))) ((= ==) (AND
(NOT !ED) 1)) (PATHELP "PATLEN invalid pattern" PATELT))))))))

($?
(LAMBDA (PATELT) (OR (EQ PATELT (QUOTE --)) (EQ PATELT (QUOTE $)))))

(ELT?
(LAMBDA (PATELT) (COND ((NLISTP PATELT) (OR (NUMBERP PATELT) (STRINGP
PATELT) (FMEMB PATELT (QUOTE (& NIL T))))) (T (SELECTQ (CAR PATELT)
((= == ' SUBPAT) T) ((← -> <- → @ *GLITCH) (ELT? (CDDR PATELT)))
((*) (ELT? (CDR PATELT))) NIL)))))

(ARB?
(LAMBDA (PATELT) (COND ((NLISTP PATELT) ($? PATELT)) (T (SELECTQ (CAR
PATELT) (! NIL) (* (ARB? (CDR PATELT))) ((<- → ← -> *GLITCH) (ARB?
(CDDR PATELT))) NIL)))))

(NULLPAT?
(LAMBDA (PAT) (AND PAT (EVERY PAT (FUNCTION $?)))))

(CANMATCHNIL
(LAMBDA (PATELT) (* Returns T if PATELT matches NIL, NIL if it doesn't,
and something ELSE (maybe) if it might (e.g., =FOO)) (COND ((NLISTP
PATELT) (AND (FMEMB PATELT (QUOTE (& NIL $ --))) T)) ((NLISTP (CAR
PATELT)) (SELECTQ (CAR PATELT) (@ (AND (CANMATCHNIL (CDDR PATELT))
(NOT (FMEMB (CADR PATELT) PATNONNILFUNCTIONS)) (QUOTE (MAYBE, MAYBE
NOT)))) (* (CANMATCHNIL (CDR PATELT))) (SUBPAT (CANMATCHNILLIST (CDR
PATELT))) ($PACKED$ (OR (NOT (NUMBERP (CDR PATELT))) (ILESSP (CDR
PATELT) 2))) ((← -> → <- *GLITCH) (CANMATCHNIL (CDDR PATELT))) (!
(CANMATCHNIL (CDR PATELT))) (' (NULL (CDR PATELT))) ((= ==) (AND 
PATVARSMIGHTBENIL (QUOTE MAYBE))) (PATHELP "CANMATCHNIL invalid pattern"
PATELT))) (T (PATHELP "CANMATCHNIL invalid pattern")))))

(CANMATCHNILLIST
(LAMBDA (PATLIST) (EVERY PATLIST (FUNCTION (LAMBDA (PE) (AND (NOT
(ELT? PE)) (CANMATCHNIL PE)))))))

(REPLACEIN
(LAMBDA (PATELT) (AND (LISTP PATELT) (SELECTQ (CAR PATELT) ((-> →
*GLITCH) (* the *GLITCH might or might not be a replace, but can't
take any chances) T) ((@ ← <-) (REPLACEIN (CDDR PATELT))) (* (* LEAVE
ROOM FOR POSS THAT X: (-- 'A --) ←FOO CONSTRUCTS MIGHT ARISE) (REPLACEIN
(CDR PATELT))) (! (REPLACEIN (CDR PATELT))) (SUBPAT (SOME (CDR PATELT)
(FUNCTION REPLACEIN))) (($PACKED$ ≠ ≠≠ = == ') (* Not needed -
really LMDEBUG) NIL) (PATHELP "Invalid pattern REPLACEIN" PATELT)))))

(REPLACED
(LAMBDA (PAT) (for X in PAT do (COND ((ELT? X) (RETURN)) ((REPLACEIN
X) (RETURN T))))))
)

(* LISP FUNCTION MANIPULATION)

(DEFINEQ

(EASYTORECOMPUTE
(LAMBDA (EXPRESSION) (* If the EXPRESSION is some cadddaars of a 
variable, return that variable (something needs to check for VARS
bound IN somes and internal forms for WHEN it can't use it for the
*'s value)) (OR (AND (NLISTP EXPRESSION) EXPRESSION) (AND (OR (GETP
(CAR EXPRESSION) (QUOTE CROPS)) (FMEMB (CAR EXPRESSION) (QUOTE (CAR
CDR)))) (EASYTORECOMPUTE (CADR EXPRESSION))))))

(FULLEXPANSION
(LAMBDA (X) (PROG (TEM) (COND ((OR (EQ (CAR X) (QUOTE CAR)) (EQ (CAR
X) (QUOTE CDR)) (NULL (SETQ TEM (FASSOC (CAR X) CRLIST)))) X) (T (LIST
(CADDDR TEM) (LIST (CAR (CDDDDR TEM)) (CADR X))))))))

(GENSYML
(LAMBDA NIL (OR (CAR (SETQ GENSYMVARLIST (CDR GENSYMVARLIST))) (GENSYM)))
)

(MAKESUBST0
(LAMBDA (OLD NEW) (SETQ SUBLIST (CONS (LIST OLD NEW) SUBLIST))))

(MAKESUBSTLIST
(LAMBDA (SUBPRS EXPR) (* This function substitues , for each element
of SUBPR (OLD . NEW) - if OLD is found only once in EXPRESSION, then
it is directly substituted - otherwise, a temp var is made up, bound,
(SETQ tem NEW) is substituted for the first occurance, and the temp
var for the rest) (PROG NIL LP (COND ((NLISTP EXPR) (COND ((NULL SUBPRS)
(RETURN EXPR)) (T (COND ((EQ (CAAR SUBPRS) EXPR) (SETQ EXPR (CADAR
SUBPRS)))) (SETQ SUBPRS (CDR SUBPRS)) (GO LP)))) (SUBPRS (RETURN (OR
(MAKESUBSTLIST1 EXPR) EXPR))) (T (RETURN EXPR))))))

(MAKESUBSTLIST1
(LAMBDA (EXPRESSION) (PROG (TEM1 TEM2) (COND ((NLISTP EXPRESSION)
NIL) ((SETQ TEM1 (FASSOC (CAR EXPRESSION) SUBPRS)) (SETQ EXPRESSION
(CONS (CAR EXPRESSION) (CDR EXPRESSION))) (COND ((LISTP (CDDR TEM1))
(SETQ TEM2 (BOUNDVAR)) (FRPLACA (CDDR TEM1) ('SETQ TEM2 (CADDR TEM1)))
(FRPLACA (CDR TEM1) TEM2) (FRPLACD (CDR TEM1) T)) ((NULL (CDDR TEM1))
(* Haven't seen it before) (FRPLACD (CDR TEM1) EXPRESSION))) (FRPLACA
EXPRESSION (OR (MAKESUBSTLIST1 (CADR TEM1)) (CADR TEM1))) (FRPLACD
EXPRESSION (OR (MAKESUBSTLIST1 (CDR EXPRESSION)) (CDR EXPRESSION)))
EXPRESSION) (T (PROG (A D) (SETQ A (MAKESUBSTLIST1 (CAR EXPRESSION)))
(SETQ D (MAKESUBSTLIST1 (CDR EXPRESSION))) (AND (OR A D) (CONS (OR
A (CAR EXPRESSION)) (OR D (CDR EXPRESSION))))))))))

(FORMEXPAND
(LAMBDA (LIST AT) (* Searches for (AT --) AT the top level of list
and does a (1) up (bo 1) on them) (for X on LIST do (AND (EQ (CAAR
X) AT) (FRPLACD X (NCONC (CDDAR X) (CDR X))) (FRPLACA X (CADAR X))))
LIST))

(POSTPONEDREPLACE
(LAMBDA (VAR VALUE) (POSTPONE ('REPLACE VAR VALUE))))

(POSTPONEDSETQ
(LAMBDA (VARTOSET VALUE CANBENILFLG) (POSTPONE ('SETQ VARTOSET VALUE)
CANBENILFLG)))

(POSTPONE
(LAMBDA (EFFECT FLG) (SETQ LASTEFFECTCANBENIL FLG) (SETQ 
POSTPONEDEFFECTS (NCONC1 POSTPONEDEFFECTS EFFECT)) (DOWATCH EFFECT)
T))

(SUBSTVAR
(LAMBDA (EXPR) (PROG (TEM) (MAKESUBST0 (SETQ TEM (GENSYML)) EXPR)
(RETURN TEM))))

(BOUNDVAR
(LAMBDA NIL (BINDVAR (GENSYML))))

(BINDVAR
(LAMBDA (VAR) (SETQ BINDINGS (CONS VAR BINDINGS)) VAR))

(SELFQUOTEABLE
(LAMBDA (EXPRESSION) (OR (NUMBERP EXPRESSION) (STRINGP EXPRESSION)
(NULL EXPRESSION) (EQ EXPRESSION T))))

(FINDIN0
(LAMBDA (VAR EXPR) (OR (FINDIN1 VAR EXPR) (SOME SUBLIST (FUNCTION
(LAMBDA (X) (AND (FINDIN1 (CAR X) EXPR) (FINDIN1 VAR (CDR X)))))))))

(FINDIN1
(LAMBDA (AT LST) (* CHEAP EDITFINDP) (OR (EQ AT LST) (AND (LISTP LST)
(OR (FINDIN1 AT (CAR LST)) (FINDIN1 AT (CDR LST)))))))

(DOWATCH
(LAMBDA (EXPR) (AND WATCHPOSTPONELST (MAP WATCHPOSTPONELST (FUNCTION
(LAMBDA (X) (AND (NEQ (CAR X) (QUOTE FOUND)) (FINDIN0 (CAR X) EXPR)
(FRPLACA X (QUOTE FOUND)))))))))

(UNCROP
(LAMBDA (EXPR) (COND ((NLISTP EXPR) EXPR) ((GETP (CAR EXPR) (QUOTE
CROPS)) (UNCROP (CADR EXPR))) (T (SELECTQ (CAR EXPR) ((CAR CDR NTH
NLEFT LAST FLAST FNTH SOME) (UNCROP (CADR EXPR))) ((MEMB FMEMB MEMBER)
(UNCROP (CADDR EXPR))) EXPR)))))

(PATNARGS
(LAMBDA (X) (OR (GETP X (QUOTE NARGS)) (NARGS X))))
)

(* LISP FUNCTION CONSTRUCTION)

(DEFINEQ

('NLEFT
(LAMBDA (EXPRESSION N TAIL NOTFASTFLG) (COND (TAIL (LIST (QUOTE NLEFT)
EXPRESSION N TAIL)) ((ZEROP N) (* NO LOOKUP DONE SINCE FLAST DOESN'T
MAKE SENSE HERE) (LIST (QUOTE CDR) (LIST (QUOTE LAST) EXPRESSION)))
((EQ N 1) (COND (NOTFASTFLG (LIST (QUOTE LAST) EXPRESSION)) (T ('LAST
EXPRESSION)))) (T (LIST (QUOTE NLEFT) EXPRESSION N)))))

('NOT
(LAMBDA (X) ('NOT1 X (QUOTE NOT))))

('NULL
(LAMBDA (X) ('NOT1 X (QUOTE NULL))))

('NOT1
(LAMBDA (X FNNAME) (COND ((NLISTP X) (SELECTQ X (NIL T) (T NIL) (LIST
FNNAME X))) (T (SELECTQ (CAR X) ((NOT NULL) (CADR X)) (EQ (FRPLACA
X (QUOTE NEQ))) (NEQ (FRPLACA X (QUOTE EQ))) ((OR AND) (for Y on (CDR
X) do (FRPLACA Y ('NOT (CAR Y)))) (FRPLACA X (COND ((EQ (CAR X) (QUOTE
AND)) (QUOTE OR)) (T (QUOTE OR))))) (LISTP (RPLACA X (QUOTE NLISTP)))
(NLISTP (FRPLACA X (QUOTE LISTP))) (LIST FNNAME X))))))

('NOTLESSPLENGTH
(LAMBDA (X N) (COND ((ZEROP N) T) (T ('NTH X N)))))

('NTH
(LAMBDA (VAR LEN) (COND ((OR (NOT (NUMBERP LEN)) (IGREATERP LEN 
MAXCDDDDRS)) (LOOKLIST (QUOTE NTH) VAR LEN)) (T (PROG NIL LP (COND
((EQ LEN 1) VAR) ((EQ LEN 2) (LIST (QUOTE CDR) VAR)) ((EQ LEN 3) (LIST
(QUOTE CDDR) VAR)) ((EQ LEN 4) (LIST (QUOTE CDDDR) VAR)) ((EQ LEN
5) (LIST (QUOTE CDDDDR) VAR)) (T (WHILE (IGREATERP LEN 5) DO (SETQ
VAR (LIST (QUOTE CDDDDR) VAR)) (SETQ LEN (IDIFFERENCE LEN 4))) (GO
LP))))))))

('OR
(LAMBDA (LISTOFEXPRESSIONS) (COND ((CDR LISTOFEXPRESSIONS) (CONS (QUOTE
OR) (FORMEXPAND LISTOFEXPRESSIONS (QUOTE OR)))) (T (CAR 
LISTOFEXPRESSIONS)))))

('PLUS
(LAMBDA (EXPR1 EXPR2) (COND ((AND (NUMBERP EXPR1) (NUMBERP EXPR2))
(IPLUS EXPR1 EXPR2)) (T (PROG ((SUM 0) (LST (FORMEXPAND (LIST EXPR1
EXPR2) (QUOTE IPLUS))) VAL) (FOR X in LST do (COND ((NUMBERP X) (SETQ
SUM (IPLUS X SUM))) (T (SETQ VAL (NCONC1 VAL X))))) (COND ((NULL VAL)
SUM) ((IGREATERP SUM 0) (CONS (QUOTE IPLUS) (CONS SUM VAL))) ((NULL
(CDR VAL)) (CAR VAL)) (T (CONS (QUOTE IPLUS) VAL))))))))

('REPLACE
(LAMBDA (VAR EXPRESSION) (SETQ VAR (FULLEXPANSION VAR)) (COND ((EQ
(CAR VAR) (QUOTE CAR)) (LOOKLIST (QUOTE RPLACA) (CADR VAR) EXPRESSION))
((EQ (CAR VAR) (QUOTE CDR)) (LOOKLIST (QUOTE RPLACD) (CADR VAR) 
EXPRESSION)) ((EQ (CAR VAR) (QUOTE LDIFF)) ('REPLACE (CADR VAR) (LIST
(QUOTE NCONC) EXPRESSION (CADDR VAR)))) (T (LIST (QUOTE RPLNODE2)
VAR EXPRESSION)))))

('SETQ
(LAMBDA (VAR EXPRESSION PROGNFLG) (SETQ EXPRESSION (LIST (QUOTE SETQ)
VAR EXPRESSION)) (COND (PROGNFLG (LIST (QUOTE PROGN) EXPRESSION T))
(T EXPRESSION))))

('AND
(LAMBDA N (PROG ((NARGS N) EXPR1 EXPR2) (SETQ EXPR2 (ARG N NARGS))
LP (SETQ NARGS (SUB1 NARGS)) (COND ((ZEROP NARGS) (RETURN EXPR2)))
(SETQ EXPR1 (ARG N NARGS)) (SETQ EXPR2 ('AND2 EXPR1 EXPR2)) (GO LP))))

('AND2
(LAMBDA (EXPR1 EXPR2) (PROG (TEM) (COND ((EQ EXPR1 T) EXPR2) ((EQ
EXPR2 T) EXPR1) ((EQUAL EXPR1 (UNCROP EXPR2)) EXPR2) ((EQ (CAR EXPR1)
(QUOTE PROGN)) (SETQ TEM (FLAST EXPR1)) (FRPLACA TEM ('AND (CAR TEM)
EXPR2)) EXPR1) ((AND (EQ (CAR EXPR2) (QUOTE COND)) (NOT (CDDR EXPR2)))
(FRPLACA (CADR EXPR2) ('AND EXPR1 (CAADR EXPR2))) EXPR2) ((AND (EQ
(CAR EXPR1) (QUOTE COND)) (NULL (CDDR EXPR1))) (FRPLACA (SETQ TEM
(FLAST (CADR EXPR1))) ('AND (CAR TEM) EXPR2)) EXPR1) ((AND (EQ (CAR
EXPR2) (QUOTE OR)) (EQ (CADDR EXPR2) T)) (LIST (QUOTE COND) (LIST
EXPR1 (CADR EXPR2) T))) ((EQ (CAR EXPR2) (QUOTE PROGN)) (LIST (QUOTE
COND) (CONS EXPR1 (CDR EXPR2)))) ((EQ (CAR EXPR2) (QUOTE AND)) (COND
((EQ (CAR EXPR1) (QUOTE AND)) (NCONC EXPR1 (CDR EXPR2))) (T (FRPLACD
EXPR2 (CONS EXPR1 (CDR EXPR2)))))) ((EQ (CAR EXPR1) (QUOTE AND)) (NCONC1
EXPR1 EXPR2)) ((AND (OR (AND (EQ (CAR EXPR1) (QUOTE SETQ)) (SETQ TEM
EXPR1)) (AND (EQ (CAR EXPR1) (QUOTE OR)) (EQ (CAADR EXPR1) (QUOTE
SETQ)) (EQ (CADDR EXPR1) T) (SETQ TEM (CADR EXPR1)))) (COND ((EQ EXPR2
(CADR TEM)) TEM) ((AND (EQ (CAR EXPR2) (QUOTE AND)) (EQ (CADR TEM)
(CADR EXPR2))) (FRPLACA (CDR EXPR2) TEM) EXPR2)))) ((AND (EQ (CAR
EXPR1) (QUOTE PROG)) (PROG (TEM) (AND (EQ (CAR (SETQ TEM (NLEFT (CDR
EXPR1) 2))) (QUOTE $$SOMELP)) (EQ (CAADR TEM) (QUOTE COND)) (NULL
(CDR (CDDADR TEM))) (EQUAL (LAST (CDAR (CDDADR TEM))) (QUOTE ((GO
$$SOMELP)))) (SETQ TEM (FLAST (CADADR TEM))) (FRPLACA TEM ('AND (CAR
TEM) EXPR2)) (RETURN EXPR1))))) (T (LIST (QUOTE AND) EXPR1 EXPR2))))))

('CAR
(LAMBDA (X) (PROG (TEM) (COND ((NULL (SETQ TEM (CADR (FASSOC (CAR
X) CRLIST)))) (LIST (QUOTE CAR) X)) (T (LIST TEM (CADR X)))))))

('CDR
(LAMBDA (X) (PROG (TEM) (COND ((NULL (SETQ TEM (CADDR (FASSOC (CAR
X) CRLIST)))) (LIST (QUOTE CDR) X)) (T (LIST TEM (CADR X)))))))

('EQ
(LAMBDA (VAR EXPRESSION) (COND ((NULL EXPRESSION) ('NULL VAR)) ((ZEROP
EXPRESSION) (LIST (QUOTE ZEROP) VAR)) (T (LIST (QUOTE EQ) VAR EXPRESSION))))
)

('EQLENGTH
(LAMBDA (VAR LEN) (* THIS SHOULD REALLY TAKE (EQLENGTH (CDDDR X) 10)
AND TRANSLATE IT TO (EQLENGTH X 13)) (COND ((EQ (CAR VAR) (QUOTE CDR))
('EQLENGTH (CADR VAR) ('PLUS LEN 1))) ((EQ (CAR VAR) (QUOTE CDDR))
('EQLENGTH (CADR VAR) ('PLUS LEN 2))) ((EQ (CAR VAR) (QUOTE CDDDDR))
('EQLENGTH (CADR VAR) ('PLUS LEN 3))) ((EQ (CAR VAR) (QUOTE CDDDR))
('EQLENGTH (CADR VAR) ('PLUS LEN 3))) ((ZEROP LEN) ('NULL VAR)) (T
(LIST (QUOTE EQLENGTH) VAR LEN)))))

('EQUAL
(LAMBDA (VAR EXPRESSION) (COND ((AND (EQ (CAR EXPRESSION) (QUOTE QUOTE))
(SELFQUOTEABLE (CADR EXPRESSION))) (SETQ EXPRESSION (CADR EXPRESSION))))
(COND ((NULL EXPRESSION) ('NULL VAR)) ((EQ EXPRESSION T) ('EQ VAR
EXPRESSION)) (T (LIST (COND ((OR (SMALLP EXPRESSION) (AND (EQ (CAR
EXPRESSION) (QUOTE QUOTE)) (LITATOM (CADR EXPRESSION)))) (QUOTE EQ))
((NUMBERP EXPRESSION) (QUOTE EQP)) ((STRINGP EXPRESSION) (QUOTE STREQUAL))
(T (QUOTE EQUAL))) VAR EXPRESSION)))))

('LAST
(LAMBDA (X) (LIST (LOOK (QUOTE LAST) X) X)))

('RETURN
(LAMBDA (VALUE) (COND (STARREPLACED ('REPLACE VALUE STARREPLACED))
(T (SETQ MUSTRETURN VALUE) T))))

('F/L
(LAMBDA (ARGS EXPR) (DSUBST (CAR ARGS) ('CAR (CADR ARGS)) EXPR) (LIST
(QUOTE FUNCTION) (COND ((AND (EQ (CADR EXPR) (CAR ARGS)) (OR (AND
(EQLENGTH EXPR 2) (EQ (PATNARGS (CAR EXPR)) 1)) (AND (EQ (PATNARGS
(CAR EXPR)) 1) (EQLENGTH EXPR 3) (EQ (CADDR EXPR) (CADR ARGS)))))
(CAR EXPR)) (T (LIST (QUOTE LAMBDA) ARGS EXPR))))))

('APPLY*
(LAMBDA (FNNAME VAR) (COND ((OR (NLISTP FNNAME) (EQ (CAR FNNAME) (QUOTE
LAMBDA))) (LIST FNNAME VAR)) (T (SUBST VAR (QUOTE @) FNNAME)))))

('HEADPLOOP
(LAMBDA (VAR HEADLIST TAILVAR CANNILFLG AFTEREXP) ('PROG NIL (LIST
('SETQ TAILVAR VAR) ('SETQ (SETQ VAR (BOUNDVAR)) HEADLIST) (QUOTE
$$LP) (LIST (QUOTE COND) (LIST (LIST (QUOTE NLISTP) VAR) (COND ((EQ
AFTEREXP T) ('OR (LIST ('NULL VAR) ('EQ VAR TAILVAR)))) ((NOT CANNILFLG)
('AND ('NULL VAR) AFTEREXP)) (T ('AND ('OR (LIST ('NULL VAR) ('EQ
VAR TAILVAR))) AFTEREXP)))) (LIST ('AND ('LISTP TAILVAR) ('EQUAL ('CAR
TAILVAR) ('CAR VAR))) ('SETQ TAILVAR ('CDR TAILVAR)) ('SETQ VAR ('CDR
VAR)) (QUOTE (GO $$LP))))))))

('LDIFF
(LAMBDA (X Y) (LIST (QUOTE LDIFF) X Y)))

('PROG
(LAMBDA (VARS STATEMENTS) (COND ((AND (NULL (CDR STATEMENTS)) (EQ
(CAAR STATEMENTS) (QUOTE PROG))) (RPLACA (CDAR STATEMENTS) (APPEND
(CADAR STATEMENTS) VARS)) (CAR STATEMENTS)) (T (CONS (QUOTE PROG)
(CONS VARS STATEMENTS))))))

('FOR
(LAMBDA ({OLD⎇ I.V. {ON⎇VAR {UNTIL⎇EXPR {FINALLY⎇EXPR NOSOMEFLG) (PROG
(TEM1) (AND (EQ {UNTIL⎇EXPR T) (PATHELP " a SOME with null terminator"
(LIST {OLD⎇ I.V. {ON⎇VAR {FINALLY⎇EXPR))) (AND NOSOMEFLG (GO DOPROG))
(SETQ TEM1 (OR (SELECTQ (CAR {UNTIL⎇EXPR) (EQ (AND (EQUAL (CADR 
{UNTIL⎇EXPR) ('CAR I.V.)) (LOOKLIST (QUOTE MEMB) (CADDR {UNTIL⎇EXPR)
{ON⎇VAR))) (EQUAL (AND (EQUAL (CADR {UNTIL⎇EXPR) ('CAR I.V.)) (LIST
(QUOTE MEMBER) (CADDR {UNTIL⎇EXPR) {ON⎇VAR))) NIL) (LIST (QUOTE SOME)
{ON⎇VAR ('F/L (LIST (GENSYML) I.V.) {UNTIL⎇EXPR)))) (COND ({OLD⎇ (*
Need to get rid if I.V., since it will be used outside) (DSUBST (GENSYML)
I.V. TEM1))) (RETURN (COND ((OR {OLD⎇ (NEQ {FINALLY⎇EXPR T)) (MAKESUBST0
I.V. TEM1) (* OLD on means that I.V. is going to be used later on.
Thus, we set up to substitute TEM1 for I.V. later, and return I.V.
now) (RETURN (COND ((NEQ {FINALLY⎇EXPR T) {FINALLY⎇EXPR) (T I.V.))))
(T TEM1))) DOPROG (RETURN ('PROG (AND (NOT {OLD⎇) (LIST (LIST I.V.
{ON⎇VAR))) (APPEND (AND {OLD⎇ (LIST ('SETQ (BINDVAR I.V.) {ON⎇VAR)))
(LIST (QUOTE $$SOMELP) (LIST (QUOTE COND) (LIST {UNTIL⎇EXPR 
{FINALLY⎇EXPR) (LIST ('LISTP I.V.) ('SETQ I.V. ('CDR I.V.)) (LIST
(QUOTE GO) (QUOTE $$SOMELP)))))))))))

('PROGN
(LAMBDA (LISTOFEXPRESSION) (COND ((CDR LISTOFEXPRESSION) (CONS (QUOTE
PROGN) LISTOFEXPRESSION)) (T (CAR LISTOFEXPRESSION)))))

('LISTP
(LAMBDA (X) (LIST (QUOTE LISTP) X)))
)

(* PATTERN PARSER)

(DEFINEQ

(PATPARSE
(LAMBDA (PAT) (SETQ PAT (PATPARSE1 (COND ((NLISTP PAT) (LIST (QUOTE
!) PAT)) (T (COPY PAT))))) (AND (LITATOM (CAR PAT)) (NOT (FMEMB (CAR
PAT) (QUOTE (& -- NIL T $)))) (PATERR (CONCAT 
"A pattern cannot begin with a " (CAR PAT)))) PAT))

(PATPARSE1
(LAMBDA (PAT BACKPAT) (* Smashes PAT with it's parsing; BACKPAT is
the previous pattern back - If it was VAR or !, leave it alone - If
it was a pattern, then don't PATPARSE the next thing, since it's an
expression) (PROG (LASTTYPE TEM) (COND ((NULL PAT) (RETURN))) RETRY
(COND ((LITATOM (CAR PAT)) (SELECTQ (CAR PAT) ((= == $PACKED$) (
PATPARSEXPR (CDR PAT)) (BI12 PAT)) (' (BI12 PAT)) ($$ (FRPLACA PAT
(QUOTE --))) ($1 (FRPLACA PAT (QUOTE &))) (* (FRPLACA PAT (CONS (QUOTE
*) (QUOTE &)))) ((& -- $ ! %. T NIL) T) (← (COND ((NEQ BACKPAT (QUOTE
VAR)) (PATPARSEXPR (CDR PAT)) (PATPARSE1 (CDDR PAT)) (RETURN PAT))))
(@ (PATPARSEXPR (CDR PAT)) (PATPARSE1 (CDDR PAT)) (RETURN PAT)) ((#
} *ANY* *EVERY* ≠ ≠≠) (PATERR (CONCAT (CAR PAT) " not implemented")))
(COND ((PATPARSEAT PAT (STRPOSL PATCHARRAY (CAR PAT) 1) PATCHARS)
(* Otherwise, try to PATPARSEAT (CAR PAT)) (GO RETRY)) (T (* Must
have a variable here!) (SETQQ LASTTYPE VAR))))) ((NLISTP (CAR PAT))
(OR (STRINGP (CAR PAT)) (NUMBERP (CAR PAT)) (PATERR (CONCAT 
"Pattern item not atom or list: " (CAR PAT))))) (T (* Otherwise, there
is a subpattern) (PATPARSE1 (CAR PAT)) (FRPLACA PAT (MAKESUBPAT (CAR
PAT))))) (AND (CDR PAT) (NLISTP (CDR PAT)) (FRPLACD PAT (LIST (QUOTE
%.) (CDR PAT)))) (PATPARSE1 (CDR PAT) (OR LASTTYPE (CAR PAT))) REPARSE
(COND ((EQ (CADR PAT) (QUOTE ←)) (* CASES FOR "←" - (1) pat←expr --->
(-> expr . pat) - (2) var←pat ----> (← var . pat) - (3) !var←pat --->
(← var ! SUBPAT . restofpattern) - (4) !←expr -----> (-> expr ! SUBPAT
. restofpattern)) (COND ((FMEMB (CAR PAT) (QUOTE (! %.))) (* !←expr)
(FRPLACA PAT (CONS (COND ((OR (NULL POSTPONEFLG) (EQ POSTPONEFLG (QUOTE
->))) (QUOTE →)) (T (QUOTE ->))) (CONS (CADDR PAT) (COND ((OR (CDDDDR
PAT) (ELT? (CADDDR PAT))) (MAKE!PAT (MAKESUBPAT (CDDDR PAT)))) (T
(CADDDR PAT)))))) (FRPLACD PAT NIL)) ((EQ LASTTYPE (QUOTE VAR)) (*
var←pat or !var←pat to ((← var . pat) ...)) (COND ((CDDR PAT) (FRPLACA
PAT (CONS (COND ((AND POSTPONEFLG (NEQ POSTPONEFLG (QUOTE ->))) (QUOTE
<-)) (T (QUOTE ←))) (CONS (CAR PAT) (CADDR PAT)))) (FRPLACD PAT (CDDDR
PAT))) (T (PATERR "nothing after a '←' in a pattern")))) (T (* pat←expr)
(SETQ TEM (CAR PAT)) (FRPLACA PAT (CDR PAT)) (FRPLACD PAT (CDDDR PAT))
(FRPLACD (CDAR PAT) TEM) (FRPLACA (CAR PAT) (COND (POSTPONEFLG (QUOTE
->)) (T (QUOTE →))))))) ((FMEMB (CAR PAT) (QUOTE (! %.))) (COND ((AND
(EQ (CAR PAT) (QUOTE !)) (FMEMB (CAADR PAT) (QUOTE (<- ←)))) (* Got
(! (← var . pe) ...) from !VAR←PE change it to (← var ! subpat pe
. ...) unless ... is NIL and pe is not ELT , in which case, just ((←
VAR . pe))) (FRPLACA PAT (COND ((AND (NULL (CDDR PAT)) (NOT (ELT?
(CDDR (CADR PAT))))) (CADR PAT)) (T (CONS (CAADR PAT) (CONS (CADR
(CADR PAT)) (MAKE!PAT (MAKESUBPAT (CONS (CDDR (CADR PAT)) (CDDR PAT)))))))))
(FRPLACD PAT NIL)) (T (FRPLACA PAT (MAKE!PAT (CADR PAT))) (FRPLACD
PAT (CDDR PAT))))) ((EQ LASTTYPE (QUOTE VAR)) (* var not followed
by ←... it's a VARDEFAULT) (FRPLACA PAT (MAKEDEFAULT (CAR PAT))))
((EQ (CADR PAT) (QUOTE @)) (FRPLACA PAT (CONS (QUOTE @) (CONS (CADDR
PAT) (CAR PAT)))) (FRPLACD PAT (CDDDR PAT))) (T (RETURN PAT))) (SETQ
LASTTYPE NIL) (GO REPARSE))))

(PATPARSEAT
(LAMBDA (PAT POS CHRS) (* Breaks apart (CAR PAT) if possible, replaces
the parsing into the beginning of PAT ; otherwise return NIL if can't
- POS is the result from STRPOSL - CHRS is a list of args to STRPOS,
i.e. check (STRPOS X:1 PAT:1 1 NIL X:2) for X in CHRS - X:1 is the
char list, X:2 is ANCHOR) (PROG (TEM) (AND (NULL POS) (RETURN)) LP
(COND ((NULL CHRS) (RETURN)) ((NOT (SETQ POS (STRPOS (CAAR CHRS) (CAR
PAT) 1 NIL (CADAR CHRS) NIL))) (SETQ CHRS (CDR CHRS)) (GO LP))) (*
Found one - Use this rather than getting pos, since some of PATCHARS
are more than one char) (SETQ TEM (IPLUS POS (CADDR (CAR CHRS))))
(COND ((NOT (IGREATERP TEM (NCHARS (CAR PAT)))) (FRPLACD PAT (CONS
(MKATOM (SUBSTRING (CAR PAT) TEM)) (CDR PAT)))) (T (SETQ TEM NIL)))
(SETQ TEM (COND ((AND TEM (EQ (CAAR CHRS) (QUOTE $)) (NOT (FMEMB (
NTHCHAR (CAR PAT) TEM) (QUOTE (← @))))) (QUOTE $PACKED$)) (T (CAAR
CHRS)))) (COND ((NEQ POS 1) (FRPLACD PAT (CONS TEM (CDR PAT))) (FRPLACA
PAT (MKATOM (SUBSTRING (CAR PAT) 1 (SUB1 POS))))) (T (FRPLACA PAT
TEM))) (RETURN T))))

(PATPARSEXPR
(LAMBDA (PAT) (* Look for ←'s in (CAR PAT)) (AND (LITATOM (CAR PAT))
(PATPARSEAT PAT (STRPOSL PATCHARRAY (CAR PAT) 1) (QUOTE ((@ NIL 1)
(← NIL 1)))))))

(BI12
(LAMBDA (PAT) (* This changes (A B ...) to ((A . B) ...)) (COND ((OR
(NLISTP PAT) (NLISTP (CDR PAT))) (PATHELP " at BI12" PAT))) (PROG
((TEM (CDR PAT))) (FRPLACD PAT (CDDR PAT)) (FRPLACD TEM (CAR TEM))
(FRPLACA TEM (CAR PAT)) (FRPLACA PAT TEM))))

(MAKEDEFAULT
(LAMBDA (PATELT LOCALVARDEFAULT) (* Turns PATELT (which is a LITATOM)
into the "DEFAULT" pattern - I.e. PATELT couldn't be parsed as a pattern
- It is assumed that the default for an atom is an element pattern)
(OR (AND (LITATOM PATELT) (NEQ PATELT T) PATELT) (PATHELP "MAKEDEFAULT"
PATELT)) (SELECTQ (OR LOCALVARDEFAULT VARDEFAULT) ((← SETQ SET) (CONS
(COND (POSTPONEFLG (QUOTE <-)) (T (QUOTE ←))) (CONS PATELT (QUOTE
$1)))) ((QUOTE ') (CONS (QUOTE ') PATELT)) ((= EQUAL) (VARCHECK PATELT)
(CONS (QUOTE =) PATELT)) ((== EQ) (VARCHECK PATELT) (CONS (QUOTE ==)
PATELT)) ((@ APPLY*) (FNCHECK PATELT) (CONS (QUOTE @) (CONS PATELT
(QUOTE &)))) (COND ((SETQ LOCALVARDEFAULT (FNCHECK PATELT T T T))
(MAKEDEFAULT LOCALVARDEFAULT (QUOTE @))) ((SETQ LOCALVARDEFAULT (
VARCHECK PATELT T T T)) (MAKEDEFAULT LOCALVARDEFAULT (QUOTE =))) (T
(PATERR (CONCAT "What is the meaing of " PATELT)))))))

(MAKE!PAT
(LAMBDA (PATELT) (OR (COND ((NLISTP PATELT) (SELECTQ PATELT (& (QUOTE
--)) (($ --) (QUOTE $)) NIL)) (T (SELECTQ (CAR PATELT) (! (PATERR
"Two !'s in a row")) ((← <- → -> @) (FRPLACD (CDR PATELT) (MAKE!PAT
(CDDR PATELT))) PATELT) (* (FRPLACD PATELT (MAKE!PAT (CDR PATELT))))
(SUBPAT (AND (NULL (CDDR PATELT)) (NOT (ELT? (CADR PATELT))) (CADR
PATELT))) ($PACKED$ PATELT) NIL))) (CONS (QUOTE !) PATELT))))

(MAKESUBPAT
(LAMBDA (PATLST) (COND ((NULL PATLST) NIL) ((OR (EQUAL PATLST (QUOTE
(--))) (EQUAL PATLST (QUOTE ($)))) (QUOTE &)) (T (CONS (QUOTE SUBPAT)
PATLST)))))
)

(* FUNCTIONS, CALLS TO WHICH ARE GENERATED)

(DEFINEQ

(EQLENGTH
(LAMBDA (X N) (COND ((ZEROP N) (NLISTP X)) (T (AND (SETQ X (NTH X
N)) (NLISTP (CDR X)))))))

(RPLNODE2
(LAMBDA (X Y) (RPLNODE X (CAR Y) (CDR Y))))

(/RPLNODE2
(LAMBDA (X Y) (/RPLNODE X (CAR Y) (CDR Y))))
)

(* MISC)

(DEFINEQ

(PATERR
(LAMBDA (MSG) (ERROR (CONCAT (OR MSG "bad pattern") " in:") TOPPAT)))

(PATHELP
(LAMBDA (MESS1 MESS2) (LISPXPRIN1 "error in Pattern Match" T) (
LISPXTERPRI T) (HELP MESS1 MESS2)))

(PATWARN
(LAMBDA (MSG) (LISPXPRIN1 MSG T) (LISPXPRIN1 " in " T) (LISPXPRINT
TOPPAT T)))

(LOOKLIST
(LAMBDA (FN ARG ARG') (LIST (LOOK FN ARG ARG') ARG ARG')))

(LOOK
(LAMBDA (FN ARG ARG') (CLISPLOOKUP FN ARG ARG' (GETP FN (QUOTE LISPFN))))
)

(CLISPLOOKUP
(LAMBDA (FN VAR1 VAR2 LISPFN) (* In most cases, it is not necessary
to do a full lookup. This is q uick an dirty check inside of the block
to avoid calling CLISPLOOKUP0 It will work whenever there are no 
declarations. Only difference between this and CLISPIFYLOOKUP is that
is that we already have performed (GETP FN 'LISPFN)) (PROG (CLASS
TEM) (RETURN (COND ((OR (AND (SETQ CLASS (GETP FN (QUOTE CLISPCLASS)))
(EQ (CAR (SETQ TEM (CADDR EXPR))) (QUOTE *)) (EQ (CADR TEM) (QUOTE
DECLARATIONS:)) (SETQ TEM (CDDDR TEM))) (AND (EQ (CAR TEM) (QUOTE
CLISP:)) (SETQ TEM (CLISPDEC0 TEM FAULTFN)))) (* must do full lookup.)
(CLISPLOOKUP0 FN VAR1 VAR2 TEM CLASS)) (T (OR LISPFN FN)))))))

(VARCHECK
(LAMBDA (VAR NOMESSFLG SPELLFLG PROPFLG) (* Checks if VAR is really
a variable - Used by MAKEDEFAULT to avoid bad parsings) (OR (AND (
LITATOM VAR) (NEQ (EVALV VAR) (QUOTE NOBIND)) VAR) (COND (NOMESSFLG
NIL) (T (ERROR VAR "NOT A VARIABLE" T))))))

(TRUE
(LAMBDA NIL T))
)
(RPAQQ VARDEFAULT NIL)
(RPAQQ MAXCDDDDRS 5)
(RPAQQ POSTPONEFLG T)
(RPAQQ PATCHECKLENGTH T)
(RPAQQ POSTPONEFLG T)
(RPAQQ PATCAREVALUE T)
(RPAQQ CRLIST ((CAR CAAR CDAR CAR NIL) (CDR CADR CDDR CDR NIL) (CDDDDR
NIL NIL CDR CDDDR) (CADDDR NIL NIL CAR CDDDR) (CDDDR CADDDR CDDDDR
CDR CDDR) (CDADDR NIL NIL CDR CADDR) (CAADDR NIL NIL CAR CADDR) (CADDR
CAADDR CDADDR CAR CDDR) (CDDR CADDR CDDDR CDR CDR) (CDDADR NIL NIL
CDR CDADR) (CADADR NIL NIL CAR CDADR) (CDADR CADADR CDDADR CDR CADR)
(CDAADR NIL NIL CDR CAADR) (CAAADR NIL NIL CAR CAADR) (CAADR CAAADR
CDAADR CAR CADR) (CADR CAADR CDADR CAR CDR) (CDDDAR NIL NIL CDR CDDAR)
(CADDAR NIL NIL CAR CDDAR) (CDDAR CADDAR CDDDAR CDR CDAR) (CDADAR
NIL NIL CDR CADAR) (CAADAR NIL NIL CAR CADAR) (CADAR CAADAR CDADAR
CAR CDAR) (CDAR CADAR CDDAR CDR CAR) (CDDAAR NIL NIL CDR CDAAR) (CADAAR
NIL NIL CAR CDAAR) (CDAAR CADAAR CDDAAR CDR CAAR) (CDAAAR NIL NIL
CDR CAAAR) (CAAAAR NIL NIL CAR CAAAR) (CAAAR CAAAAR CDAAAR CAR CAAR)
(CAAR CAAAR CDAAR CAR CAR)))
(RPAQQ PATCHARS ((' T 1) (← NIL 1) (@ NIL 1) (! T 1) (== T 2) (= T
1) ($ T 1)))
(RPAQQ PATNONNILFUNCTIONS (GETD NUMBERP STRINGP ZEROP LISTP))
(RPAQQ PATVARSMIGHTBENIL T)
(DEFLIST(QUOTE(
(EVERY (X (CMAP X (QUOTE (CAR MACROX)) (QUOTE (EVERYLP (COND ((NLISTP
MACROX) (RETURN T)) ((NOT MAPF) (RETURN NIL))) (SETQ MACROX MAPF2)
(GO EVERYLP))))))
))(QUOTE MACRO))

(ADDTOVAR PRETTYMACROS (* X (E (TERPRI) (PRINT (QUOTE (* . X))) (TERPRI))))
(SETQ PATCHARRAY (MAKEBITTABLE (MAPCAR PATCHARS (QUOTE CAR))))
(DECLARE
(BLOCK: MATCHBLOCK MAKEMATCH 'MATCHWM 'MATCHTOP 'MATCHEXP 'MATCHELT
'MATCHSUBPAT MAKE'SETQ MAKEPOSTPONEDSETQ MAKE'REPLACE 
MAKEPOSTPONEDREPLACE MAKE'APPLY* MAKE'RETURN MAKE*GLITCH SKIP$I SKIP$ANY
PATLEN $? ELT? ARB? NULLPAT? CANMATCHNIL CANMATCHNILLIST REPLACEIN
REPLACED EASYTORECOMPUTE FULLEXPANSION GENSYML MAKESUBST0 MAKESUBSTLIST
MAKESUBSTLIST1 FORMEXPAND POSTPONEDREPLACE POSTPONEDSETQ POSTPONE
SUBSTVAR BOUNDVAR BINDVAR SELFQUOTEABLE FINDIN0 FINDIN1 DOWATCH UNCROP
'NLEFT 'NOT 'NULL 'NOT1 'NOTLESSPLENGTH 'NTH 'OR 'PLUS 'REPLACE 'SETQ
'AND 'AND2 'CAR 'CDR 'EQ 'EQLENGTH 'EQUAL 'LAST 'RETURN 'APPLY* 
'HEADPLOOP 'LDIFF 'PROG 'FOR 'F/L 'PROGN 'LISTP PATPARSE PATPARSE1
PATPARSEAT PATPARSEXPR BI12 MAKEDEFAULT MAKE!PAT MAKESUBPAT PATERR
PATHELP PATWARN LOOKLIST LOOK CLISPLOOKUP VARCHECK PATNARGS TRUE 
EQLENGTH (ENTRIES MAKEMATCH) (GLOBALVARS PATCHARRAY PATCHARS POSTPONEFLG
VARDEFAULT CRLIST PATCHECKLENGTH MAXCDDDDRS PATNONNILFUNCTIONS 
PATVARSMIGHTBENIL) (LOCALFREEVARS WATCHPOSTPONELST SUBLIST TOPPAT
INASOME CHECKINGLENGTH WMLST LASTEFFECTCANBENIL POSTPONEDEFFECTS 
MUSTRETURN BINDINGS GENSYMVARLIST SKIPEDLEN ZLENFLG SUBPRS STARREPLACED)
(SPECVARS STARREPLACED) (BLKAPPLYFNS TRUE MAKE'RETURN MAKE*GLITCH
MAKE'SETQ MAKEPOSTPONEDSETQ MAKE'REPLACE MAKEPOSTPONEDREPLACE 
MAKE'APPLY* 'MATCHWM 'MATCHSUBPAT))
(BLOCK: NIL EQLENGTH RPLNODE2 /RPLNODE2 (LINKFNS . T))
)STOP